[PATCH] <short summary of the patch>

TODO: Put a short summary on the line above and replace this paragraph
with a longer explanation of this change. Complete the meta-information
with other relevant fields (see below for details). To make it easier, the
information below has been extracted from the changelog. Adjust it or drop
it.

Bug-Debian: https://bugs.debian.org/1140970

Gbp-Pq: Name Version_2_7_2pre35

diff --git a/Makefile.am b/Makefile.am
index 12c526d553532204a73f7c8c285a266e48530876..a95e54b1990eb1faff3d675d2c4169afa1248784 100644 (file)
--- a/Makefile.am
+++ b/Makefile.am
@@ -210,7 +210,7 @@ gcl_tk_gcltkaux_SOURCES=$(GCLTK_SRC)
 gcl_tk_gcltkaux_CPPFLAGS=$(AM_CPPFLAGS) $(TK_INCLUDE) $(TCL_INCLUDE) $(TK_XINCLUDES)
 gcl_tk_gcltkaux_LDADD=$(TK_LIB_SPEC) $(TCL_LIB_SPEC)
 
-MY_DIRS=gcl0 gcl1 gcl2 gcl3 gcl mod_gcl0 mod_gcl pcl_gcl ansi_gcl
+MY_DIRS=gcl0 gcl1 gcl2 gcl3 gcl mod_gcl0 mod_gcl pcl_gcl ansi_gcl0 ansi_gcl
 
 L_STUBS=s sf c listlib predlib deftype typeof subtypep bit type typep typecase arraylib \
         seq seqlib bnum fle dl rm nr lr sym hash sharp \
@@ -285,8 +285,9 @@ unixport/gcl_cmpnopt_%_gprof.lsp: unixport/gcl_cmpnopt_%.lsp
 unixport/gcl_cmpnopt_pre_gcl.lsp: # FIXME necessary?
        touch $@
 unixport/gcl_cmpnopt_%.lsp: unixport/lib%.a | unixport/%
-       echo "(mapc (quote load) (directory \"$*/*.hsh\"))" \
-            "(compiler::dump-inl-hash \"$@\" t)" | $|
+       echo "(clrhash compiler::*inl-hash*)" \
+             "(mapc (quote load) (directory \"$*/*.hsh\"))" \
+            "(compiler::dump-inl-hash \"$@\")" | $|
 
 $(addprefix unixport/lib,$(addsuffix .a,pre_gcl $(MY_DIRS))): \
 unixport/lib%.a: lib/libbase_gcl.a $(LIBGPROF) unixport/sys_%.o
@@ -306,9 +307,14 @@ $(addprefix unixport/lib,$(addsuffix .a,gcl1 gcl2 gcl3 gcl)):\
 unixport/lib%.a: $(addprefix %/,$(L_OBJS))
 unixport/libmod_gcl0.a unixport/libmod_gcl.a:\
 unixport/lib%.a: $(addprefix %/,$(MOD_OBJS)) $(L_FOBJS) $(X_LIB)
-unixport/libgcl.a unixport/libmod_gcl.a: unixport/lib%.a: %/recompile
 unixport/libpcl_gcl.a: $(PCL_FOBJS)
-unixport/libansi_gcl.a: $(ANSI_FOBJS)
+unixport/libansi_gcl0.a unixport/libansi_gcl.a: \
+unixport/lib%.a: $(addprefix %/,$(CLCS_OBJS)) $(PCL_FOBJS)
+
+unixport/libgcl.a unixport/libmod_gcl.a unixport/libansi_gcl.a: unixport/lib%.a: %/recompile
+gcl/recompile: $(L_FOBJS)
+mod_gcl/recompile: $(MOD_FOBJS)
+ansi_gcl/recompile: $(ANSI_FOBJS)
 
 unixport/libgcl_gprof.a: $(patsubst %.o,%.go,$(L_FOBJS))
 unixport/libansi_gcl_gprof.a: $(patsubst %.o,%.go,$(ANSI_FOBJS))
@@ -319,6 +325,7 @@ unixport/lib%.a: | xbin/ar_merge
 %/recompile: | unixport/%
        $| -batch \
           -eval "(let ((si::*do-recomp-output-dir* \"$(@D)\")) (si::do-recomp t))" \
+          -eval "(mapc (quote delete-file) (directory \"$(@D)/*.hsh\"))" \
           -eval "(compiler::dump-inl-hash \"$(@D)/all.hsh\" t)"
        touch $@
 
@@ -334,11 +341,12 @@ unixport/gcl:  | unixport/saved_gcl3
 unixport/mod_gcl0:  | unixport/saved_gcl
 unixport/mod_gcl:  | unixport/saved_mod_gcl0
 unixport/pcl_gcl:  | unixport/saved_mod_gcl
-unixport/ansi_gcl:  | unixport/saved_pcl_gcl
+unixport/ansi_gcl0:  | unixport/saved_pcl_gcl
+unixport/ansi_gcl:  | unixport/saved_ansi_gcl0
 $(addprefix unixport/,gcl0 gcl1): unixport/% : unixport/cinit.lisp | %
        echo "(system:save-system \"$@\")" | cat $< - | $(word 2,$|)
 
-$(addprefix unixport/,gcl2 gcl3 gcl mod_gcl): unixport/% : | %
+$(addprefix unixport/,gcl2 gcl3 gcl mod_gcl ansi_gcl): unixport/% : | %
        ln -snf $$(basename $(word 2,$|)) $@
 
 unixport/mod_gcl0: xgcl-2/sysdef.lisp | mod_gcl0
@@ -359,9 +367,9 @@ unixport/pcl_gcl: clcs/package.lisp cmpnew/gcl_collectfn.lsp pcl/defsys.lisp  |
              "(setq pcl::*pathname-extensions* (cons \"lisp\" \"o\"))" \
              "(si::save-system \"$@\")" | $(word 2,$|)
 
-unixport/ansi_gcl: clcs/package.lisp clcs/gcl_clcs_precom.lisp \
+unixport/ansi_gcl0: clcs/package.lisp clcs/gcl_clcs_precom.lisp \
                   clcs/gcl_clcs_conditions.lisp clcs/gcl_clcs_condition_definitions.lisp \
-                  | ansi_gcl
+                  | ansi_gcl0
        echo "(mapc (quote load) (list $(patsubst %,\"%\",$^)))" \
              "(compiler::cdebug)" \
              "(si::save-system \"$@\")" | $(word 2,$|)
@@ -388,12 +396,12 @@ gcl1/%.o: | unixport/gcl1
 $(addprefix gcl2/,$(LL_OBJS)): gcl2/%.o : lsp/%.lsp
 $(addprefix gcl2/,$(LC_OBJS)): gcl2/%.o : cmpnew/%.lsp
 gcl2/%.o: | unixport/gcl2
-       $| -eval "(compiler::cdebug)(setq compiler::*dump-inl-hash* t)" -compile $< -o $@
+       $| -eval "(progn (compiler::cdebug)(setq compiler::*dump-inl-hash* t))" -compile $< -o $@
 
 $(addprefix gcl3/,$(LL_OBJS)): gcl3/%.o : lsp/%.lsp
 $(addprefix gcl3/,$(LC_OBJS)): gcl3/%.o : cmpnew/%.lsp
 gcl3/%.o: | unixport/gcl3
-       $| -eval "(compiler::cdebug)(setq compiler::*dump-inl-hash* t)" -compile $< -o $@
+       $| -eval "(progn (compiler::cdebug)(setq compiler::*dump-inl-hash* t))" -compile $< -o $@
 
 gcl/%.o: gcl3/%.o | gcl
        cp $(patsubst %.o,%.*,$<) $(@D)
@@ -406,7 +414,6 @@ mod_gcl0/%.o: | unixport/mod_gcl0
 mod_gcl/%.o: mod_gcl0/%.o | unixport/mod_gcl
        cp $(patsubst %.o,%.*,$<) $(@D)
 
-
 %/c1: | unixport/%
        echo "(pcl::compile-pcl)" | $|
        touch $@
@@ -450,9 +457,13 @@ $(addprefix pcl_gcl/,$(PCL_OBJS)): pcl_gcl/all.hsh
        touch $@
 
 
-ansi_gcl/%.o: clcs/%.lisp | unixport/ansi_gcl
+ansi_gcl0/%.o: clcs/%.lisp | unixport/ansi_gcl0
        $| -eval "(setq compiler::*dump-inl-hash* t)" -compile $< -o $@
 
+ansi_gcl/%.o: ansi_gcl0/%.o | unixport/ansi_gcl
+       cp $(patsubst %.o,%.*,$<) $(@D)
+
+
 %.go: %.o mod_gcl/recompile #FIXME parallel
        $(CC) $(AM_CPPFLAGS) -I $(<D) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) \
              -fno-omit-frame-pointer -pg -c $*.c -o $@

diff --git a/Makefile.in b/Makefile.in
index 5676efe7283dcbf30e4049f5865ac69cbaa06d74..7cb6ff4096005b304051d7550b95861f07702ff1 100644 (file)
--- a/Makefile.in
+++ b/Makefile.in
@@ -1100,7 +1100,7 @@ GCLTK_SRC = gcl-tk/guis.c gcl-tk/tkAppInit.c gcl-tk/tkMain.c gcl-tk/guis.h
 gcl_tk_gcltkaux_SOURCES = $(GCLTK_SRC)
 gcl_tk_gcltkaux_CPPFLAGS = $(AM_CPPFLAGS) $(TK_INCLUDE) $(TCL_INCLUDE) $(TK_XINCLUDES)
 gcl_tk_gcltkaux_LDADD = $(TK_LIB_SPEC) $(TCL_LIB_SPEC)
-MY_DIRS = gcl0 gcl1 gcl2 gcl3 gcl mod_gcl0 mod_gcl pcl_gcl ansi_gcl
+MY_DIRS = gcl0 gcl1 gcl2 gcl3 gcl mod_gcl0 mod_gcl pcl_gcl ansi_gcl0 ansi_gcl
 L_STUBS = s sf c listlib predlib deftype typeof subtypep bit type typep typecase arraylib \
         seq seqlib bnum fle dl rm nr lr sym hash sharp \
        cmptype cmpeval cmpvar cmpwt cmpif \
@@ -4624,8 +4624,9 @@ unixport/gcl_cmpnopt_%_gprof.lsp: unixport/gcl_cmpnopt_%.lsp
 unixport/gcl_cmpnopt_pre_gcl.lsp: # FIXME necessary?
        touch $@
 unixport/gcl_cmpnopt_%.lsp: unixport/lib%.a | unixport/%
-       echo "(mapc (quote load) (directory \"$*/*.hsh\"))" \
-            "(compiler::dump-inl-hash \"$@\" t)" | $|
+       echo "(clrhash compiler::*inl-hash*)" \
+             "(mapc (quote load) (directory \"$*/*.hsh\"))" \
+            "(compiler::dump-inl-hash \"$@\")" | $|
 
 $(addprefix unixport/lib,$(addsuffix .a,pre_gcl $(MY_DIRS))): \
 unixport/lib%.a: lib/libbase_gcl.a $(LIBGPROF) unixport/sys_%.o
@@ -4639,9 +4640,14 @@ $(addprefix unixport/lib,$(addsuffix .a,gcl1 gcl2 gcl3 gcl)):\
 unixport/lib%.a: $(addprefix %/,$(L_OBJS))
 unixport/libmod_gcl0.a unixport/libmod_gcl.a:\
 unixport/lib%.a: $(addprefix %/,$(MOD_OBJS)) $(L_FOBJS) $(X_LIB)
-unixport/libgcl.a unixport/libmod_gcl.a: unixport/lib%.a: %/recompile
 unixport/libpcl_gcl.a: $(PCL_FOBJS)
-unixport/libansi_gcl.a: $(ANSI_FOBJS)
+unixport/libansi_gcl0.a unixport/libansi_gcl.a: \
+unixport/lib%.a: $(addprefix %/,$(CLCS_OBJS)) $(PCL_FOBJS)
+
+unixport/libgcl.a unixport/libmod_gcl.a unixport/libansi_gcl.a: unixport/lib%.a: %/recompile
+gcl/recompile: $(L_FOBJS)
+mod_gcl/recompile: $(MOD_FOBJS)
+ansi_gcl/recompile: $(ANSI_FOBJS)
 
 unixport/libgcl_gprof.a: $(patsubst %.o,%.go,$(L_FOBJS))
 unixport/libansi_gcl_gprof.a: $(patsubst %.o,%.go,$(ANSI_FOBJS))
@@ -4652,6 +4658,7 @@ unixport/lib%.a: | xbin/ar_merge
 %/recompile: | unixport/%
        $| -batch \
           -eval "(let ((si::*do-recomp-output-dir* \"$(@D)\")) (si::do-recomp t))" \
+          -eval "(mapc (quote delete-file) (directory \"$(@D)/*.hsh\"))" \
           -eval "(compiler::dump-inl-hash \"$(@D)/all.hsh\" t)"
        touch $@
 
@@ -4667,11 +4674,12 @@ unixport/gcl:  | unixport/saved_gcl3
 unixport/mod_gcl0:  | unixport/saved_gcl
 unixport/mod_gcl:  | unixport/saved_mod_gcl0
 unixport/pcl_gcl:  | unixport/saved_mod_gcl
-unixport/ansi_gcl:  | unixport/saved_pcl_gcl
+unixport/ansi_gcl0:  | unixport/saved_pcl_gcl
+unixport/ansi_gcl:  | unixport/saved_ansi_gcl0
 $(addprefix unixport/,gcl0 gcl1): unixport/% : unixport/cinit.lisp | %
        echo "(system:save-system \"$@\")" | cat $< - | $(word 2,$|)
 
-$(addprefix unixport/,gcl2 gcl3 gcl mod_gcl): unixport/% : | %
+$(addprefix unixport/,gcl2 gcl3 gcl mod_gcl ansi_gcl): unixport/% : | %
        ln -snf $$(basename $(word 2,$|)) $@
 
 unixport/mod_gcl0: xgcl-2/sysdef.lisp | mod_gcl0
@@ -4692,9 +4700,9 @@ unixport/pcl_gcl: clcs/package.lisp cmpnew/gcl_collectfn.lsp pcl/defsys.lisp  |
              "(setq pcl::*pathname-extensions* (cons \"lisp\" \"o\"))" \
              "(si::save-system \"$@\")" | $(word 2,$|)
 
-unixport/ansi_gcl: clcs/package.lisp clcs/gcl_clcs_precom.lisp \
+unixport/ansi_gcl0: clcs/package.lisp clcs/gcl_clcs_precom.lisp \
                   clcs/gcl_clcs_conditions.lisp clcs/gcl_clcs_condition_definitions.lisp \
-                  | ansi_gcl
+                  | ansi_gcl0
        echo "(mapc (quote load) (list $(patsubst %,\"%\",$^)))" \
              "(compiler::cdebug)" \
              "(si::save-system \"$@\")" | $(word 2,$|)
@@ -4721,12 +4729,12 @@ gcl1/%.o: | unixport/gcl1
 $(addprefix gcl2/,$(LL_OBJS)): gcl2/%.o : lsp/%.lsp
 $(addprefix gcl2/,$(LC_OBJS)): gcl2/%.o : cmpnew/%.lsp
 gcl2/%.o: | unixport/gcl2
-       $| -eval "(compiler::cdebug)(setq compiler::*dump-inl-hash* t)" -compile $< -o $@
+       $| -eval "(progn (compiler::cdebug)(setq compiler::*dump-inl-hash* t))" -compile $< -o $@
 
 $(addprefix gcl3/,$(LL_OBJS)): gcl3/%.o : lsp/%.lsp
 $(addprefix gcl3/,$(LC_OBJS)): gcl3/%.o : cmpnew/%.lsp
 gcl3/%.o: | unixport/gcl3
-       $| -eval "(compiler::cdebug)(setq compiler::*dump-inl-hash* t)" -compile $< -o $@
+       $| -eval "(progn (compiler::cdebug)(setq compiler::*dump-inl-hash* t))" -compile $< -o $@
 
 gcl/%.o: gcl3/%.o | gcl
        cp $(patsubst %.o,%.*,$<) $(@D)
@@ -4781,9 +4789,12 @@ mod_gcl/%.o: mod_gcl0/%.o | unixport/mod_gcl
 $(addprefix pcl_gcl/,$(PCL_OBJS)): pcl_gcl/all.hsh 
        touch $@
 
-ansi_gcl/%.o: clcs/%.lisp | unixport/ansi_gcl
+ansi_gcl0/%.o: clcs/%.lisp | unixport/ansi_gcl0
        $| -eval "(setq compiler::*dump-inl-hash* t)" -compile $< -o $@
 
+ansi_gcl/%.o: ansi_gcl0/%.o | unixport/ansi_gcl
+       cp $(patsubst %.o,%.*,$<) $(@D)
+
 %.go: %.o mod_gcl/recompile #FIXME parallel
        $(CC) $(AM_CPPFLAGS) -I $(<D) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) \
              -fno-omit-frame-pointer -pg -c $*.c -o $@

diff --git a/cmpnew/gcl_cmpeval.lsp b/cmpnew/gcl_cmpeval.lsp
index d6b71a68334b0dd5d40c9dc0a09dd18a9a6040ca..1ceffc3aefea5d0f015bfb1e258aaca87fe16e69 100644 (file)
--- a/cmpnew/gcl_cmpeval.lsp
+++ b/cmpnew/gcl_cmpeval.lsp
@@ -619,7 +619,7 @@
   (if (unless (type-and t1 t2) (and a1 a2 (listp t1) (listp t2) (equal (car t1) (car t2))))
       (car t1) (type-or1 t1 t2)))
 
-(defun coalesce-inl (cl inl tps rt &aux (lev (this-safety-level)))
+(defun coalesce-inl (cl inl tps rt lev);&aux (lev (this-safety-level))
   (when (> lev (third inl))
     (keyed-cmpnote (list (car cl) 'inl-hash 'inl-hash-coalesce)
                   "Coalescing safety ~s: ~s ~s" (car cl) (third inl) lev)
@@ -694,7 +694,7 @@
 
 (defun merge-inl (cl inl pl &aux (tps (pop inl))(tr (pop inl)))
   (let ((z (member-if (lambda (x) (can-coalesce x tr inl tps)) (car pl))))
-    (cond (z (coalesce-inl cl (car z) tps (cdr (third inl)))
+    (cond (z (coalesce-inl cl (car z) tps (cdr (third inl)) (car inl))
             (setf (cdr z) (remove-if (lambda (x) (can-coalesce x tr inl tps)) (cdr z))))
          (pl (let ((x (list* tps tr inl)))
                (keyed-cmpnote (list (car cl) 'inl-hash 'inl-hash-add)
@@ -766,25 +766,86 @@
          x)))))
 
 
-(defun compress-inl (s &aux (i (car (gethash s *inl-hash*))))
-  (when (> (length i) 1)
-    (let ((l (length i))
-         (x (reduce (lambda (y x)
-                      (list
-                       (mapl (lambda (z w) (setf (car z) (type-or1 (car z) (car w))))
-                             (car y) (car x))
-                       (max (cadr y) (third x))))
-                    (cdr i) :initial-value (list (copy-list (caar i)) (third (car i)))))
-         (syms (mapcar (lambda (x) (declare (ignore x)) (gensym)) (make-list (length (caar i))))))
-      (compile nil `(lambda ,syms
-                     (declare (optimize (safety ,(cadr x)))
-                              ,@(mapcar (lambda (x y) (list (cmp-unnorm-tp x) y)) (car x) syms))
-                     (,s ,@syms)))
-      (when (< (length (car (gethash s *inl-hash*))) l)
-       (format t "compress-inl ~s: ~s -> ~s~%" s l (length (car (gethash s *inl-hash*))))))))
-
-(defun dump-inl-hash (f &optional compress &aux (si::*print-package* t))
-  (when compress (maphash (lambda (x y) (declare (ignore y)) (compress-inl x)) *inl-hash*))
+(defvar *ncompiles* 0)
+
+(defun try-compile (nm s tps
+                   &aux (*sig-discovery* t)
+                     *compile-verbose*
+                     (syms (mapcar (lambda (x) (declare (ignore x)) (gensym)) tps)))
+  (incf *ncompiles*)
+  (compile nil `(lambda ,syms
+                 (declare (optimize (safety ,s)))
+                 (declare ,@(mapcar (lambda (x y) (list (cmp-unnorm-tp x) y)) tps syms))
+                 (,nm ,@syms))))
+
+(defun extend-arg-tps (at tps s)
+  (let* ((st (member '* at))
+        (at (ldiff at st))
+        (at (if (< s 2) at (make-list (length at) :initial-element #tt))))
+    (append at
+           (when st
+             (make-list (- (length tps) (length at)) :initial-element #tt)))))
+
+(defun restrict-inl-1-tps (nm at inls)
+  (mapc (lambda (inl)
+         (mapl (lambda (ptp pstp &aux (tp (car ptp))(stp (car pstp)))
+                 (unless (tp<= tp stp)
+                   (let ((ntp (tp-and tp stp)))
+                     (print (list nm (caddr inl) (cmp-unnorm-tp tp) 'to (cmp-unnorm-tp ntp)))
+                     (setf (car ptp) ntp))))
+                 (car inl)
+                 (extend-arg-tps at (car inl) (caddr inl))))
+       (car inls)))
+
+(defun iterate-over-inls (nm at &optional (it 0)
+                         &aux (inls (copy-tree (get-inl-list (list nm))))
+                           (have-2 (member 2 (car inls) :key 'caddr)))
+
+  (flet ((try (s tps chg) ;(print (list 'trying nm s (mapcar 'cmp-unnorm-tp tps)))
+          (try-compile nm s tps)
+          (unless (equal inls (get-inl-list (list nm)))
+            (print (list nm s (mapcar 'cmp-unnorm-tp tps) chg))
+            (return-from iterate-over-inls (iterate-over-inls nm at (1+ it))))))
+    (mapc (lambda (inl &aux (tps (copy-list (car inl))))
+           (when (eql 0 (caddr inl))
+             (try 1 (car inl) (list 0 '-> 1)))
+           (mapl (lambda (ptp pstp &aux (tp (car ptp))(stp (car pstp)))
+                   (unless (tp>= tp stp)
+                     (let ((ntp (tp-and stp (or (parent tp) t))))
+                       (setf (car ptp) ntp)
+                       (try (caddr inl) tps (list (cmp-unnorm-tp tp) '-> (cmp-unnorm-tp ntp)))
+                       (setf (car ptp) tp))))
+                 tps (extend-arg-tps at tps (caddr inl)))
+           (unless have-2
+             (when (eq (caddr inl) 1)
+               (try 2 (car inl) (list 1 '-> 2))
+               (let ((tps (copy-list (car inl))))
+                 (mapl (lambda (ptp &aux (tp (car ptp)))
+                         (mapc (lambda (c)
+                                 (setf (car ptp) c)
+                                 (try 2 tps (list (cmp-unnorm-tp tp) '-> (cmp-unnorm-tp c))))
+                               (all-children tp))
+                         (setf (car ptp) tp))
+                       tps)))))
+         (car inls))
+    it))
+
+(defun finalize-inls (nm &aux (*ncompiles* 0)(at (get-arg-types nm))(inls (get-inl-list (list nm))))
+  (restrict-inl-1-tps nm at inls)
+  (list (iterate-over-inls nm at) *ncompiles*  (show-inls nm)))
+
+(defun finalize-all-inls (&aux redo)
+  (maphash (lambda (x y)
+            (declare (ignore y))
+            (unless (zerop (car (finalize-inls x)))
+              (setq redo t)))
+          *inl-hash*)
+  (when redo
+    (finalize-all-inls)))
+
+(defun dump-inl-hash (f &optional finalize &aux (si::*print-package* t))
+  (when finalize (finalize-all-inls))
+;  (when compress (maphash (lambda (x y) (declare (ignore y)) (compress-inl x)) *inl-hash*))
   (with-open-file (s f :direction :output)
     (prin1 '(in-package :compiler) s)
     (terpri s)
@@ -800,9 +861,9 @@
                                      (list ,@(mapcan
                                               (lambda (x)
                                                 `((list ',(pop x) ',(pop x) ',(mapcar 'export-type (car x)))))
-                                              (cadr z)))
+                                              (sort (cadr z) '< :key (lambda (x) (hash-equal x -5)))))
                                      ,(caddr z)))
-                            (car y))))
+                            (sort (car y) '< :key (lambda (x) (hash-equal x -5))))))
                s)
               (terpri s))
          (let (r)

diff --git a/git.tag b/git.tag
index 3737f7cdcd20fab93e4094a010279dbc40cd577d..80fa1659a9f9149e6d0a3611891cf4d8b47c0712 100644 (file)
--- a/git.tag
+++ b/git.tag
@@ -1 +1 @@
-"Version_2_7_2pre34"
+"Version_2_7_2pre35"

diff --git a/h/protoize.h b/h/protoize.h
index f8f93144c5bace6fec6d809fb820dcd7c94f4052..4f31480438b3abd1393bec0652c192a7e03ba753 100644 (file)
--- a/h/protoize.h
+++ b/h/protoize.h
@@ -1670,7 +1670,6 @@ int msbrk_end(void);
 object quick_call_function_vec(object,ufixnum,object *);
 int msbrk_initialized(void);
 void *mdlopen(const char *,int);
-void close_dlopen_list(void);
 void set_global_env_defaults(void);
 void disable_aslr(int,char **,char **);
 void set_leak_malloc_on(void);

diff --git a/lsp/gcl_callhash.lsp b/lsp/gcl_callhash.lsp
index 828dae2fad7f9027a5e3709acaf9bcbdfd48258b..e38f901f247cf2e9abcc1b913a62cbff4e44cd00 100644 (file)
--- a/lsp/gcl_callhash.lsp
+++ b/lsp/gcl_callhash.lsp
@@ -290,7 +290,7 @@
   (dolist (s (gen-all-ftype-symbols))
     (let* ((f (or (file s) ""))
           (sig (car (sym-plist s))))
-      (when (and sig (member f fl :test 'string=));e.g. fns in o/, interpreted, wrong-file
+      (when (and sig (member f fl :test 'search));e.g. fns in o/, interpreted, wrong-file
        (push (list s sig) r))))
   (write-sys-proclaims1 sp r))
 

diff --git a/lsp/gcl_iolib.lsp b/lsp/gcl_iolib.lsp
index f206330abcf1529f0501d9b8591b0134ab2c2ae6..93d28dbc24151fcad4571afd31a2e3e52828c1a3 100644 (file)
--- a/lsp/gcl_iolib.lsp
+++ b/lsp/gcl_iolib.lsp
@@ -533,6 +533,7 @@
 
 (declaim (inline byte-index))
 (defun byte-index (k n)
+  #+:clx-little-endian (declare (ignore n))
   #+:clx-little-endian k #-:clx-little-endian (- n 1 k))
 
 (defun read-byte (s &optional (eof-error-p t) eof-value &aux (i 0)(tp (stream-element-type s)))

diff --git a/lsp/gcl_mnum.lsp b/lsp/gcl_mnum.lsp
index 7f76765ebf88ae4f375dad8eaeb3c0608bc7df66..94203077539d6e325bc1e684364d25f9c256852a 100644 (file)
--- a/lsp/gcl_mnum.lsp
+++ b/lsp/gcl_mnum.lsp
@@ -66,12 +66,12 @@
 (defdlfun (:double    "carg"     ) :dcomplex)
 
 (defun bsqrt (x);this is an instruction, or a jump to main body
-  (declare (long-float x))
+  (check-type x long-float)
   (lit :double "sqrt(" (:double x) ")"))
 (setf (get 'bsqrt 'compiler::cmp-inline) t)
 
 (defun bsqrtf (x);this is an instruction, or a jump to main body
-  (declare (short-float x))
+  (check-type x short-float)
   (lit :float "sqrtf(" (:float x) ")"))
 (setf (get 'bsqrtf 'compiler::cmp-inline) t)
 

diff --git a/lsp/gcl_subtypep.lsp b/lsp/gcl_subtypep.lsp
index b243ebd83a5b785b2ea75ab4526a25bc92c6476a..349d60e2a05d91c865a9cdedb3ef2151f9210bff 100644 (file)
--- a/lsp/gcl_subtypep.lsp
+++ b/lsp/gcl_subtypep.lsp
@@ -601,8 +601,10 @@
     (cond ((ntp-subtp x m) x)
          ((unless ux (ntp-subtp xy xx)) oy)
          ((unless uy (ntp-subtp xx xy)) ox)
-         ((list (list x m `(and ,(if ux (car lx) (car (nreconstruct-type ox)))
-                                ,(if uy (car ly) (car (nreconstruct-type oy)))))
+         ((list (list x m
+                      (let ((x (if ux (car lx) (car (nreconstruct-type ox))))
+                            (y (if uy (car ly) (car (nreconstruct-type oy)))))
+                        (if (equal x y) x `(and ,x ,y))))
                 d t)))))
 
 (defun ntp-or-unknown (ox lx ux oy ly uy d)
@@ -611,8 +613,10 @@
     (cond ((ntp-subtp x m) x)
          ((unless ux (ntp-subtp mx my)) oy)
          ((unless uy (ntp-subtp my mx)) ox)
-         ((list (list x m `(or ,(if ux (car lx) (car (nreconstruct-type ox)))
-                               ,(if uy (car ly) (car (nreconstruct-type oy)))))
+         ((list (list x m
+                      (let ((x (if ux (car lx) (car (nreconstruct-type ox))))
+                            (y (if uy (car ly) (car (nreconstruct-type oy)))))
+                        (if (equal x y) x `(or ,x ,y))))
                 d t)))))
 
 (defun ntp-and?c2-nil-p (x y ?c2)

diff --git a/lsp/gcl_type.lsp b/lsp/gcl_type.lsp
index fc4f54c17f10aa994c5f5da4c9c9d5d6b5427652..19e3e85d695f55d9bc7364a3bef4a4872c4ff4ef 100644 (file)
--- a/lsp/gcl_type.lsp
+++ b/lsp/gcl_type.lsp
@@ -4,7 +4,7 @@
 (export '(cmp-norm-tp tp-p
          cmp-unnorm-tp
 ;        type-and type-or1 type>= type<=
-         tp-not tp-and tp-or tp<= tp>= tp= uniq-tp tsrch uniq-sig
+         tp-not tp-and tp-or tp<= tp>= tp= uniq-tp tsrch parent all-children uniq-sig
          atomic-tp tp-bnds object-tp
          cmpt t-to-nil returs-exactly funcallable-symbol-function
          infer-tp cnum creal long
@@ -758,6 +758,23 @@
     (when x
       (or (tsrch tp (cdar x)) (caar x)))))
 
+(defun parent (tp &optional (y *useful-type-tree*))
+  (let ((x (member tp y :test (lambda (x y) (unless (tp<= y x) (tp<= x y))) :key 'car)))
+    (when x
+       (or (parent tp (cdar x)) (caar x)))))
+
+(defun children (tp &optional (y (list (cons #tt *useful-type-tree*))))
+  (let ((x (member tp y :test 'tp<= :key 'car)))
+    (when x
+      (or (children tp (cdar x)) (cdar x)))))
+
+(defun flatten-children (c)
+  (mapcan (lambda (x) (cons (car x) (flatten-children (cdr x)))) c))
+
+(defun all-children (tp)
+  (remove-duplicates (flatten-children (children tp))))
+
+
 (defvar *uniq-tp* (make-hash-table :test 'eq))
 
 (defun uniq-tp (tp)

diff --git a/o/alloc.c b/o/alloc.c
index 9d2b06b3148605c0900cea05a165d5b43e770b4a..014952301d9516c7d2248500b2301c61e9495826 100644 (file)
--- a/o/alloc.c
+++ b/o/alloc.c
@@ -1841,12 +1841,12 @@ realloc(void *ptr, size_t size) {
        VFILLP_SET(x,size);
        return(ptr);
       } else {
-       memset(x->st.st_self,0,x->st.st_dim);
        x->st.st_self = alloc_contblock(size);
+       for (i = 0;  i < x->st.st_dim;  i++)
+         x->st.st_self[i] = ((char *)ptr)[i];
+       memset(ptr,0,x->st.st_dim);
        x->st.st_dim = size;
        VSET_MAX_FILLP(x);
-       for (i = 0;  i < size;  i++)
-         x->st.st_self[i] = ((char *)ptr)[i];
        return(x->st.st_self);
       }
     }

diff --git a/o/cfun.c b/o/cfun.c
index eba5e3ae77b06feba84c213aea040ff235a03ffe..c721cdaf1d6e94be5b5e79446bcdeeea644db9b8 100644 (file)
--- a/o/cfun.c
+++ b/o/cfun.c
@@ -76,14 +76,6 @@ DEFUN("CFDL",object,fScfdl,SI,0,0,NONE,OO,OO,OO,OO,(void),"") {
   RETURN1(Cnil);
 }
 
-DEFVAR("*DLOPEN-HANDLES*",sSAdlopen_handlesA,SI,Cnil,"");
-
-void
-close_dlopen_list(void) {
-  for (;sSAdlopen_handlesA->s.s_dbind!=Cnil;sSAdlopen_handlesA->s.s_dbind=sSAdlopen_handlesA->s.s_dbind->c.c_cdr)
-    dlclose((void *)fix(sSAdlopen_handlesA->s.s_dbind->c.c_car));
-}
-
 void *
 mdlopen(const char *name,int flags) {
 
@@ -95,13 +87,8 @@ mdlopen(const char *name,int flags) {
   set_leak_malloc_off();
   if ((err=dlerror()))
     FEerror("dlopen failure on ~s: ~s",2,name,make_simple_string(err));
-  if (name) {
-    object x=sSAdlopen_handlesA->s.s_dbind;
-    for (;x!=Cnil && fix(x->c.c_car)!=(fixnum)v;x=x->c.c_cdr);
-    if (x==Cnil)
-      sSAdlopen_handlesA->s.s_dbind=MMcons(make_fixnum((fixnum)v),sSAdlopen_handlesA->s.s_dbind);
+  if (name)
     update_real_maxpage();
-  }
 
   return v;
 }

diff --git a/o/error.c b/o/error.c
index 65557dcde3dd946108311180cced5ca86fec3c6c..43a3af503380f60596b8a28596750f787140d30a 100644 (file)
--- a/o/error.c
+++ b/o/error.c
@@ -33,7 +33,7 @@ object siSuniversal_error_handler;
 object sSterminal_interrupt;
 
 #if defined(__APPLE__)
-char *
+const char *
 strerrordesc_np(int errnum) {
   return (errnum >= 0 && errnum < sys_nerr) ? sys_errlist[errnum] : "Unknown error";
 }

diff --git a/o/save.c b/o/save.c
index 0eb056cbaee0fb2d1a0b6b462035f9a453081e04..4bf3ed1abc2dd9faa7784f2b8034c7eb8f9975c0 100644 (file)
--- a/o/save.c
+++ b/o/save.c
@@ -21,17 +21,17 @@ LFD(siLsave)(void) {
   extern void *shared_lib_start;
   extern jmp_buf gmp_jmp;
   extern object sSreset_lib_syms;
+  object x=vs_base[0];
 
   check_arg(1);
 
-  memset(FN1,0,sizeof(FN1));
-  coerce_to_filename(vs_base[0], FN1);
-
   ifuncall1(sSreset_lib_syms,Cnil);
-  close_dlopen_list();
   frs_top=frs_org-1;
   gcl_cleanup(1);
 
+  memset(FN1,0,sizeof(FN1));
+  coerce_to_filename(x,FN1);
+
   /*FIXME clean this up when done*/
 
   set_leak_malloc_on();

diff --git a/unixport/init_raw.lsp.in b/unixport/init_raw.lsp.in
index 4763afdc6be0d9cd1b4341cdb9a4eb0a2a1c4e58..9387ca860d8e01cf2b753bb3bba0634be8fd3df6 100644 (file)
--- a/unixport/init_raw.lsp.in
+++ b/unixport/init_raw.lsp.in
@@ -55,6 +55,7 @@
        (lsp (append x (list "lsp")))
        (cmpnew (append x (list "cmpnew")))
        (h (append x (list "h")))
+       (u (append x (list "unixport")))
        (xgcl-2 (append x (list "xgcl-2")))
        (pcl (append x (list "pcl")))
        (clcs (append x (list "clcs")))
@@ -64,7 +65,7 @@
   (load (make-pathname :name "tk-package" :type "lsp" :directory gtk))
   (load (make-pathname :name "gcl_lfun_list" :type "lsp" :directory cmpnew))
   (load (make-pathname :name "gcl_cmpopt" :type "lsp" :directory cmpnew))
-  (let* ((x (merge-pathnames (make-pathname :name "gcl_cmpnopt" :type "lsp") *system-directory*)))
+  (let* ((x (make-pathname :name "gcl_cmpnopt" :type "lsp" :directory u)))
     (when (probe-file x) (load x)))
   (load (make-pathname :name "gcl_auto_new" :type "lsp" :directory lsp))